home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-04
/
aie8911.zip
/
LIB.ARI
< prev
next >
Wrap
Text File
|
1989-08-27
|
32KB
|
844 lines
%%%%%%%%%% end prepcomp generated declarations %%%%%%%%%%%%%%%%%%%%
% :- module lib.
:- visible write_error/1.
/*************************************************************************/
/***************** member : set membership ******************************/
/*************************************************************************/
% Note : this does not backtrack
/* member( X, L ) succeeds if X is a member of list L */
member( X, [ X | _ ] ) :- !. /* If X is the first element of */
/* a set then member is true */
member( X, [ _ | T ] ) :- member( X, T ).
/* Otherwise, membership */
/* depends on the tail of the */
/* list. */
/*************************************************************************/
/***************** memb : backtracing version of member ******************/
/*************************************************************************/
memb( X, [ X | Y ] ).
memb( X, [ Y | Z ] ) :- memb( X, Z ).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
minimum( [], 0 ) :- !.
minimum( [ M ], M ) :- !.
minimum( [ M, K ], M ) :- M =< K, ! .
minimum( [ M | R ], N ) :- minimum( R, K ),
minimum( [ K, M ], N ).
maximum( [], 0 ) :- !.
maximum( [ M ], M ) :- !.
maximum( [ M, K ], M ) :- M >= K, !.
maximum( [ M | R ], N ) :- maximum( R, K ), maximum( [ K, M ], N ).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%% append : appends lists %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
/*
Note: Original academic version changed.
backtracking eliminated with the cut.
The loss of generality usually does not matter,
but the backtracking can lead to weird behaviour in a fail loop,
for example.
*/
append( [], X, X ) :- !.
append( [ X | Y ], Z, [ X | W ] ) :- append( Y, Z, W ).
/*************************************************************************/
/************** lc_char : converts char. to lower case *******************/
/*************************************************************************/
lc_char( In, Out ) :-
is_uc( In ), !, Out is In + 32.
lc_char( In, In ).
/*************************************************************************/
/************** lc_char : converts char. to lower case *******************/
/*************************************************************************/
lc_char( In, Out ) :-
is_uc( In ), !, Out is In + 32.
lc_char( In, In ).
/*************************************************************************/
/*************** is_list : is arg. a list *******************************/
/*************************************************************************/
is_list( [] ) .
is_list( [_ | _ ] ) .
/*************************************************************************/
/*************** union : union of sets ********************************/
/*************************************************************************/
/* union computes the union of two sets */
union( [], B, B ) :- !. /* union of an empty set with */
/* set */
/* set B is B */
union( [ H | T ], B, U ) :- /* union of a set with head H */
/* and */
/* a set B, with result going */
/* into */
/* U */
member( H, B ), /* If H is already in B */
union( T, B, U ), !. /* union B with the tail of */
/* first set */
union( [ H | T ], B, [ H | U ] ) :- /* If H is not in B, add it as */
/* the head */
union( T, B, U ), !. /* of the union set, and make */
/* the tail */
/* of the union the union of */
/* the tail of */
/* the first set and B */
/*************************************************************************/
/*************** blank_line : succeed for line with nothing on it *******/
/*************************************************************************/
blank_line( Line) :-
string_length( Line, 0),
file_trace($blank line found$),
!.
blank_line( Line) :-
list_text( List, Line),
blanks_list( List),
file_trace([$blank line in chars : $, List]).
blanks_list([]) :- !,
file_trace($blank line found$).
blanks_list([H|T]) :-
is_separator(H), !,
blanks_list(T).
/*************************************************************************/
/*************** reverse : reverses a list ***************************/
/*************************************************************************/
/* reverse( List, Reverse ) reverses a list, putting the reverse of List in
Reverse */
reverse( List, Reverse ) :- reverse1( List, [], Reverse ).
/* reverse uses reverse1( ToDo, SoFar, NextStep ) , where,
ToDo = the tail of the input list that still needs to be
reversed,
SoFar = The part of the reversed list built so far,
NextStep = the complete reversed list */
reverse1( [], Result, Result ). /* If ToDo is empty, return */
/* SoFar */
/* which contains reversed list */
reverse1( [ H | T ], SoFar, Result ) :-
/* If ToDo is non-empty */
reverse1( T, [ H | SoFar ], Result ).
/* move the head element of */
/* ToDo */
/* to So_far ( note that later
elements of ToDo are put by later
calls to reverse1 BEFORE the
current head ). Then apply reverse1
to the tail of the current list. */
/**************** strip_off_extra_blanks *********************************/
/*
Call:
strip_off_extra_blanks(In_string, Out_string)
Input args:
In_string = a string
Output args:
Out_string = In_string with leading and trailing blanks stripped off
Success conditions : always_succeeds
*/
strip_off_extra_blanks(In_string, Out_string) :-
string( In_string ),!,
strip_off_initial_blanks(In_string, Temp),!,
strip_off_trailing_blanks( Temp , Out_string).
strip_off_extra_blanks(In_string, Out_string) :-
convert_to_string( In_string, S_In_string),
strip_off_extra_blanks( S_In_string , Out_string).
/**************** strip_off_trailing_blanks ******************************/
/*
Call:
strip_off_trailing_blanks(In_string, Out_string)
Input args:
In_string = a string
Output args:
Out_string = In_string with trailing blanks stripped off
Success conditions : always_succeeds
*/
strip_off_trailing_blanks(In_string, Out_string) :-
string( In_string ),!,
string_length( In_string , Lnth),!,
Pos is Lnth - 1,
strip_off_trailing_blanks_hlpr( In_string, Pos , Out_string).
strip_off_trailing_blanks(In_string, Out_string) :-
convert_to_string( In_string, S_In_string), !,
strip_off_trailing_blanks(S_In_string, Out_string).
/**************** strip_off_trailing_blanks_hlpr **************************/
/*
Call:
strip_off_trailing_blanks_hlpr( In_string, Pos, Out_string)
Input args:
In_string = a string
Position = NEXT char position to be tested to see if it is a blank
Output args:
Out_string = In_string with trailing blanks stripped off
Success conditions : always_succeeds
*/
strip_off_trailing_blanks_hlpr( In_string, Pos, Out_string) :-
Pos < 0,!,
Out_string = $$.
strip_off_trailing_blanks_hlpr( In_string, Pos, Out_string) :-
nth_char(Pos, In_string, Char),
is_separator( Char),!,
Pos1 is Pos - 1,
strip_off_trailing_blanks_hlpr( In_string, Pos1, Out_string).
strip_off_trailing_blanks_hlpr( In_string, Pos, Out_string) :-
Lnth is Pos + 1,
substring(In_string, 0, Lnth, Out_string).
/**************** strip_off_initial_blanks ********************************/
/*
Call:
strip_off_initial_blanks(In_string, Out_string)
Input args:
In_string = a string
Output args:
Out_string = In_string with leading blanks stripped off
Success conditions : always_succeeds
*/
strip_off_initial_blanks(In_string, Out_string) :-
string( In_string ),!,
string_length( In_string , Lnth),!,
strip_off_initial_blanks_hlpr(0, In_string, Lnth, Out_string).
strip_off_initial_blanks(In_string, Out_string) :-
convert_to_string( In_string, S_In_string), !,
strip_off_initial_blanks(S_In_string, Out_string).
/**************** strip_off_initial_blanks_hlpr ***************************/
/*
Call:
strip_off_initial_blanks_hlpr(Position, In_string, Lnth, Out_string)
Input args:
Position = NEXT char position to be tested to see if it is a blank
In_string = a string
Lnth = length of input string
Output args:
Out_string = In_string with leading blanks stripped off
Success conditions : always_succeeds
*/
strip_off_initial_blanks_hlpr(Position, In_string, Lnth , Out_string) :-
Position >= Lnth,!,
Out_string = $$.
strip_off_initial_blanks_hlpr(Position, In_string, Lnth , Out_string) :-
nth_char(Position, In_string, Char),
is_separator( Char),!,
Position1 is Position +1,
strip_off_initial_blanks_hlpr(Position1,
In_string,
Lnth ,
Out_string).
strip_off_initial_blanks_hlpr(Position,
In_string,
Lnth ,
Out_string) :-
Left_over_length is Lnth - Position,!,
substring(In_string, Position, Left_over_length , Out_string).
/*************************************************************************/
/*************** convert_to_string : converts data to string ********/
/*************************************************************************/
convert_to_string(X,X):-string(X),!.
convert_to_string(X,String):-
atom(X),!,atom_string(X,String).
convert_to_string(X,String):-
float(X),!,float_text(X,String,general).
convert_to_string(X,String):-
integer(X),!,int_text(X,String).
convert_to_string(X,String):-
var(X),!,
string_term(Y,X),
concat($Var$,Y,String).
convert_to_string([],$[]$):-!.
convert_to_string([H|T],String):-
convert_to_strings([H|T],L1),
put_in_commas(L1,L2),
concat(L2,S3),
concat([$[$,S3,$]$],String),!.
convert_to_string(X,String):-
X=..[Functor|Args],!,
atom_string(Functor,S_functor),
convert_to_strings(Args,S_args),
put_in_commas(S_args,S_args_with_commas),
concat(S_args_with_commas,S_arg_string),
concat([S_functor,$( $,S_arg_string,$ )$],String).
convert_to_string(_,$Undefined print string$).
/*************************************************************************/
/*********** convert_to_strings : converts list of items to strings ******/
/*************************************************************************/
/*
convert_to_strings( Termlist, Stringlist )
converts a list of terms to a list of strings.
*/
convert_to_strings([],[]).
convert_to_strings([ H | T ], [ H1 | T1 ]):-
convert_to_string(H , H1 ),
convert_to_strings(T , T1 ).
/*************************************************************************/
/********* put_in_separators : puts separators in a list ****************/
/*************************************************************************/
put_in_separators([],_,[]):-!.
put_in_separators([H],_,[H]):-!.
put_in_separators([H|T],Separator,[H,Separator|T1]):-
put_in_separators(T,Separator,T1).
/*************************************************************************/
/********* put_in_commas : puts commas in a list ********************/
/*************************************************************************/
put_in_commas(List,Separated):-
put_in_separators(List,$, $,Separated).
/*************************************************************************/
/********* non_empty : true for non-empty sets ***************************/
/*************************************************************************/
non_empty( [_ | _ ]).
/*************************************************************************/
/********* delete_from_head : deletes string from head of string *********/
/*************************************************************************/
delete_from_head( Main_string, Head_description, String_tail) :-
strip_off_extra_blanks( Main_string, Main_string2 ),
exists_at_head( Main_string2, Head_description),
string_description_length( Head_description,
Head_lnth),
string_length( Main_string2, Main_lnth),
Tail_lnth is Main_lnth - Head_lnth,
Tail_lnth >= 0,
substring( Main_string2, Head_lnth, Tail_lnth, String_tail).
/*************************************************************************/
/********* exists_at_head : does a string exist at the head of a main***/
/*****************************string *************************************/
/*************************************************************************/
exists_at_head( Main_string, Pattern) :-
string( Pattern),
!,
string_search(1, Pattern, Main_string, 0).
exists_at_head( Main_string, Pattern) :-
atom( Pattern),
!,
atom_string( Pattern, S_pattern),
exists_at_head( Main_string, S_pattern) .
exists_at_head( Main_string, Pattern) :-
integer( Pattern),
!,
string_length( Main_string, Main_lnth),
Main_lnth >= Pattern.
/*************************************************************************/
/***** delete_from_tail_if_there : deletes string from tail end of *****/
/***** string if the pattern is there *****/
/*************************************************************************/
delete_from_tail_if_there( Main_string,
Tail_description,
String_seg ) :-
delete_from_tail( Main_string,
Tail_description,
String_seg ),
!.
delete_from_tail_if_there( Main_string,
_,
Main_string ) :- !.
/*************************************************************************/
/***** delete_from_head_if_there : deletes string from head end of *****/
/***** string if the pattern is there *****/
/*************************************************************************/
delete_from_head_if_there( Main_string,
Head_description,
String_seg ) :-
delete_from_head( Main_string,
Head_description,
String_seg ),
!.
delete_from_head_if_there( Main_string,
_,
Main_string ) :- !.
/*************************************************************************/
/********* delete_from_tail : deletes string from tail end of string *****/
/*************************************************************************/
delete_from_tail( Main_string, Tail_description, String_seg ) :-
strip_off_extra_blanks( Main_string, Main_string2 ),
exists_at_tail( Main_string2, Tail_description),
string_description_length( Tail_description,
Tail_description_lnth),
string_length( Main_string2, Main_lnth),
Output_part_lnth is Main_lnth - Tail_description_lnth,
Output_part_lnth >= 0,
substring( Main_string2, 0,
Output_part_lnth, String_seg ).
/*************************************************************************/
/********* exists_at_tail : does a string exist at the tail of a main***/
/*****************************string *************************************/
/*************************************************************************/
exists_at_tail( Main_string, Pattern) :-
string( Pattern),
!,
string_description_length( Pattern,
Pattern_lnth),
string_length( Main_string, Main_lnth),
Output_start is Main_lnth - Pattern_lnth,
string_search(1, Pattern, Main_string, Output_start ).
exists_at_tail( Main_string, Pattern) :-
atom( Pattern),
!,
atom_string( Pattern, S_pattern),
exists_at_tail( Main_string, S_pattern) .
exists_at_tail( Main_string, Pattern) :-
integer( Pattern),
!,
string_length( Main_string, Main_lnth),
Main_lnth >= Pattern.
/*************************************************************************/
/********* string_description_length : length of a string from a data ****/
/************************************ item describing its length ********/
/*************************************************************************/
string_description_length( Description, Description) :-
integer( Description ),
!.
string_description_length( Description, Lnth ) :-
atom( Description),
!,
atom_string( Description, S_description),
string_length( S_description, Lnth).
string_description_length( Description, Lnth ) :-
string( Description),
!,
string_length( Description, Lnth) .
/*************************************************************************/
/********* once : does a goal only once **********************************/
/*************************************************************************/
once(X) :- call(X), !.
/*************************************************************************/
/********* write_error : writes error message ****************************/
/*************************************************************************/
write_error( Error) :-
write_error( [], Error).
write_error( Handles, Error) :-
build_error_handle_list( Handles, Handles2),
!,
add_on_error_msg( Error, Errs2 ) ,
!,
trace_msg_hlpr2( Handles2, Errs2 ).
build_error_handle_list( Handles, Handles2) :-
is_list( Handles ),
!,
get_trace_handle( LogHandle ),
!,
union( Handles, [ 1 , LogHandle ], Handles2).
build_error_handle_list( Handles, Handles2) :-
integer( Handles),
!,
build_error_handle_list( [Handles], Handles2).
build_error_handle_list( _ , Handles2) :-
build_error_handle_list( [] , Handles2) .
add_on_error_msg( Error, Error_with_error_header) :-
Error = [_ | _],
!,
error_header( Header ),
Error_with_error_header = [ Header | Error].
add_on_error_msg( Error, Error_with_error_header) :-
Error = [],
!,
error_header( Header ),
Error_with_error_header = Header .
add_on_error_msg( Error, Error_with_error_header) :-
error_header( Header ),
Error_with_error_header = [ Header , Error].
error_header( $ACHTUNG !! ACHTUNG !! -- ERROR : $).
/*************************************************************************/
/********* retractall : retracts all instances of a goal *****************/
/*************************************************************************/
retractall( Name / Arity) :-
integer(Arity),
!,
functor(Term, Name, Arity),
retractall( Term).
retractall( X) :-
retract(X),
fail.
retractall( _).
/*************************************************************************/
/***************** append_to_end : adds item to end of list *************/
/*************************************************************************/
append_to_end(X,Y,Z):-append1(X,Y,Z).
/* provide both easy to remember
and short names */
/* append1( Elt, Oldset, Newset ) adds Elt to end of Oldset and puts result
in Newset */
append1( Elt , [] , [ Elt ] ) :- !. /* If Oldsdet is empty, the result
contains only the newly added
element. */
append1( Elt, [ H | T ] , [ H | T1 ] ) :-
/* Otherwise, make the head of */
/* the Oldset the head of the */
/* new list */
append1( Elt , T , T1 ). /* and append the new element */
/* to the */
/* tail of the current Oldset */
/*************************************************************************/
/***************** list_length : length of a list **********************/
/*************************************************************************/
/* list_length( L, N ) finds the length of the list L and puts it into N */
list_length( [], 0 ) :- !. /* empty list has length 0 */
list_length( [ _ | T ], N ) :- /* For a non-empty list */
list_length( T, M ), !, /* get length of tail */
N is M+1. /* and add 1 to it */
/*************************************************************************/
/******* merge : merges two sorted lists into a single sorted list ******/
/*************************************************************************/
mergetrace(X) :- trace_message( mergetrace, X).
mergetrace :- !
,fail
.
/* merge(Sorted_list_1,Sorted_list_2,Order, Merged_list) merges
Sorted_list_1 and Sorted_list_2 into a single sorted list, Merged_list.
Order is an order relation such as =<.
*/
merge(Arg1,Arg2,_,_):-
mergetrace([$e merge: Arg1=$,Arg1,$Arg2=$,Arg2]),fail.
merge([],T,_,T):-!, /* merge of a list with [] does not */
mergetrace([$x merge 1=empty : $,T]).
merge(T,[],_,T):-!, /* alter the non-empty list */
mergetrace([$x merge 2=empty : $,T]).
merge([H1|T1],[H2|T2],Order, [H1|Merged_list1]):-
Temp=..[Order,H1,H2], /* If Order(H1,H2) is true */
call(Temp),!, /* H1 is first in merged list */
merge(T1,[H2|T2],Order,Merged_list1),
mergetrace([$x merge 1 first : $,[H1|Merged_list1]]).
merge(List1,[H2|T2],Order, [H2|Merged_list1]):-
/* Otherwise H2 is first in merged */
/* list */
merge(List1,T2,Order,Merged_list1),
mergetrace([$x merge 2 first : $,[H2|Merged_list1]]).
/* merge also exists in a simpler form that uses the standard order
relation =< */
merge([],T,T):-!. /* merge of a list with [] does not */
merge(T,[],T):-!. /* alter the non-empty list */
merge([H1|T1],[H2|T2], [H1|Merged_list1]):-
% do_or_die([
H1 =< H2,!, /* If H1 =< H2 is true */
merge(T1,[H2|T2],Merged_list1)
% ],mergetrace)
.
/* H1 is first in merged list */
merge(List1,[H2|T2], [H2|Merged_list1]):-
/* Otherwise H2 is first in merged */
/* list */
merge(List1,T2,Merged_list1).
/*************************************************************************/
/******* merge_sort : sorts a list using merge_sort algorithm ************/
/*************************************************************************/
/* merge_sort(Unsorted,Order,Sorted) sorts an unsorted list Unsorted using
the binary order relation Order, and puts the resulting list into
the variable Sorted. */
merge_sort([],_,[]):-!. /* empty list is sorted */
merge_sort([H],_,[H]):-!. /* 1-element list is sorted */
merge_sort(Unsorted,Order,Sorted):-
% do_or_die([
partition_in_half(Unsorted, Half1, Half2),
/* partition list into halves */
merge_sort(Half1,Order,Sorted_half1), /* sort the halves */
merge_sort(Half2,Order,Sorted_half2), /* merge them together */
merge(Sorted_half1,Sorted_half2,Order,Sorted)
% ],mergetrace)
.
/* This sort also comes in a form that uses the standard order relation
=< implicitly: */
merge_sort([],[]):-!. /* empty list is sorted */
merge_sort([H],[H]):-!. /* 1-element list is sorted */
merge_sort(Unsorted,Sorted):-
% do_or_die([
partition_in_half(Unsorted, Half1, Half2),
/* partition list into halves */
merge_sort(Half1,Sorted_half1), /* sort the halves */
merge_sort(Half2,Sorted_half2), /* merge them together */
merge(Sorted_half1,Sorted_half2,Sorted)
% ],mergetrace)
.
/* both versions of merge use the following predicate that partitions
a list in half */
partition_in_half(Unsorted,Half1,Half2):-
partition_in_half1(Unsorted,[],[],1,Half1,Half2).
partition_in_half1([],H1,H2,_,H1,H2):-!.
/* when input list is empty, */
/* partition is finished */
partition_in_half1([H|T],Sofar1,Sofar2,1,Half1,Half2):-!,
partition_in_half1(T,[H|Sofar1],Sofar2,2,Half1,Half2).
/* when last argument is 1, put */
/* head of input into first half */
/* put first of rest in 2nd half */
partition_in_half1([H|T],Sofar1,Sofar2,2,Half1,Half2):-!,
partition_in_half1(T,Sofar1,[H|Sofar2],1,Half1,Half2).
/* when last argument is 2, put */
/* head of input into 2nd half */
/* put first of rest in 1st half */
%%%%%%%%%%%%%%%%%%% start of is_char char classificaiton preds %%%%%%%%%%%%
/*************************************************************************/
/************** is_separator : succeeds if character is a separator *****/
/*************************************************************************/
is_separator( C ) :- C ==32. % space
is_separator( C ) :- C ==12. % form feed
is_separator( C ) :- C ==13. % cr
is_separator( C ) :- C ==10. % lf
is_separator( C ) :- C ==9 . % tab
is_separator( C ) :- C ==26. % eof
/*************************************************************************/
/************** is_lc : succeeds if character is lower case *************/
/*************************************************************************/
is_lc( C ) :-
C >= `a, C =< `z.
/*************************************************************************/
/************** is_uc : succeeds if character is upper case *************/
/*************************************************************************/
is_uc( C ) :-
C >= `A, C =< `Z.
/*************************************************************************/
/************** is_digit : succeeds if character is a digit *************/
/*************************************************************************/
is_digit( C ) :-
C >= `0, C =< `9.
/*************************************************************************/
/************** is_letter : succeeds if character is a letter ************/
/*************************************************************************/
is_letter( C ) :- is_lc( C ) ,! ;
is_uc( C ) ,! .
/*************************************************************************/
/************** is_alphanum : succeeds if character is alphanumeric *****/
/*************************************************************************/
is_alphanum( C ) :- is_lc( C ) ,! ;
is_uc( C ) ,! ;
is_digit( C ) ,! ;
C == `_ ,! .
/*************************************************************************/
/************** separator : true for separators ************************/
/*************************************************************************/
separator( X ) --> [ X ],
{is_separator(X)}.
%%%%%%%%%%%%%%%%%%% end of is_char char classificaiton preds %%%%%%%%%%%%
/*************************************************************************/
/************** write_error : write error message ************************/
/*************************************************************************/
write_error( List ) :-
log_write($ERROR -- $),
write_list( List).
/*************************************************************************/
/************** write_list : write a list *******************************/
/*************************************************************************/
write_list( [] ) :- log_nl, !.
write_list( [H|T] ) :-
log_write(H), log_tab(1),
write_list(T).
% eof